Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/midifi1a/frmsplas.frm

Visual Basic Form | 1999-10-02 | 5.8 KB | 162 lines

VERSION 5.00
Begin VB.Form frmSplash
   BorderStyle     =   3  'Fixed Dialog
   ClientHeight    =   2235
   ClientLeft      =   255
   ClientTop       =   1410
   ClientWidth     =   8355
   ClipControls    =   0   'False
   ControlBox      =   0   'False
   Icon            =   "frmSplash.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form2"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2235
   ScaleWidth      =   8355
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'CenterScreen
   Begin VB.FileListBox fillist
      Height          =   1650
      Left            =   6345
      TabIndex        =   4
      Top             =   0
      Visible         =   0   'False
      Width           =   1950
   End
   Begin VB.DirListBox Dirlist
      Height          =   1440
      Left            =   0
      TabIndex        =   3
      Top             =   0
      Visible         =   0   'False
      Width           =   2175
   End
   Begin VB.Label Label3
      Caption         =   "Please wait while i find all of your midi files."
      Height          =   195
      Left            =   0
      TabIndex        =   2
      Top             =   1620
      Width           =   3975
   End
   Begin VB.Label Label2
      Caption         =   "MIDI PLAY"
      BeginProperty Font
         Name            =   "Courier New"
         Size            =   36
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   690
      Left            =   2295
      TabIndex        =   1
      Top             =   270
      Width           =   4020
   End
   Begin VB.Label Label1
      Height          =   285
      Left            =   45
      TabIndex        =   0
      Top             =   1890
      Width           =   8250
   End
Attribute VB_Name = "frmSplash"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim SearchFlag As Integer   ' Used as flag for cancel and other operations.
Private Sub cmdSearch_Click()
' Initialize for search, then perform recursive search.
Dim FirstPath As String, DirCount As Integer, NumFiles As Integer
Dim result As Integer
    FirstPath = Dirlist.Path
    DirCount = Dirlist.ListCount
    ' Start recursive direcory search.
    result = DirDiver(FirstPath, DirCount, "")
    Form1.Show
    Unload Me
End Sub
Private Function DirDiver(NewPath As String, DirCount As Integer, BackUp As String) As Integer
'  Recursively search directories from NewPath down...
'  NewPath is searched on this recursion.
'  BackUp is origin of this recursion.
'  DirCount is number of subdirectories in this directory.
Static FirstErr As Integer
Dim DirsToPeek As Integer, AbandonSearch As Integer, ind As Integer
Dim OldPath As String, ThePath As String, entry As String
Dim retval As Integer
    SearchFlag = True           ' Set flag so the user can interrupt.
    DirDiver = False            ' Set to True if there is an error.
    retval = DoEvents()         ' Check for events (for instance, if the user chooses Cancel).
    If SearchFlag = False Then
        DirDiver = True
        Exit Function
    End If
    On Local Error GoTo DirDriverHandler
    DirsToPeek = Dirlist.ListCount                  ' How many directories below this?
    Do While DirsToPeek > 0 And SearchFlag = True
        OldPath = Dirlist.Path                      ' Save old path for next recursion.
        Dirlist.Path = NewPath
        If Dirlist.ListCount > 0 Then
            ' Get to the node bottom.
            Dirlist.Path = Dirlist.List(DirsToPeek - 1)
            AbandonSearch = DirDiver((Dirlist.Path), DirCount%, OldPath)
        End If
        ' Go up one level in directories.
        DirsToPeek = DirsToPeek - 1
        If AbandonSearch = True Then Exit Function
    Loop
    ' Call function to enumerate files.
    If fillist.ListCount Then
        If Len(Dirlist.Path) <= 3 Then             ' Check for 2 bytes/character
            ThePath = Dirlist.Path                  ' If at root level, leave as is...
        Else
            ThePath = Dirlist.Path + "\"            ' Otherwise put "\" before the filename.
        End If
        For ind = 0 To fillist.ListCount - 1        ' Add conforming files in this directory to the list box.
            entry = ThePath + fillist.List(ind)
            Form1.List1.AddItem entry
            Label1.Caption = entry

        Next ind
    End If
    If BackUp <> "" Then        ' If there is a superior directory, move it.
        Dirlist.Path = BackUp
    End If
    Exit Function
DirDriverHandler:
    If Err = 7 Then             ' If Out of Memory error occurs, assume the list box just got full.
        DirDiver = True         ' Create Msg and set return value AbandonSearch.
        MsgBox "You've filled the list box. Abandoning search..."
        Exit Function           ' Note that the exit procedure resets Err to 0.
    Else                        ' Otherwise display error message and quit.
        MsgBox Error
        End
    End If
End Function
Private Sub Dirlist_Change()
  fillist.Path = Dirlist.Path
End Sub
Private Sub DirList_LostFocus()
    Dirlist.Path = Dirlist.List(Dirlist.ListIndex)
End Sub
Private Sub Form_Load()
fillist.Pattern = "*.mid"
Dirlist.Path = "C:\"
Dirlist.Refresh
Me.Show
Dim FirstPath As String, DirCount As Integer, NumFiles As Integer
Dim result As Integer
    FirstPath = Dirlist.Path
    DirCount = Dirlist.ListCount
    ' Start recursive direcory search.
    results = DirDiver(FirstPath, DirCount, "")
    Form1.Show
    Unload Me
End Sub